home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / expand.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  3.9 KB  |  115 lines

  1. (herald (hax expand t 10))
  2.  
  3. ;;; (EXPAND form syntax-table)  ->  form
  4. ;;;     Recursively macro-expands the form.
  5.  
  6. (define (tas-expand exp syntax)
  7.   (cond ((not (pair? exp)) exp)
  8.         (else
  9.          (let ((head (car exp)))
  10.            (cond ((symbol? head)
  11.                   (cond ((syntax-table-entry syntax head)
  12.                          => (lambda (descr)
  13.                               (tas-expand-special-form descr exp syntax)))
  14.                         (else
  15.                          (tas-expand-call exp syntax))))
  16.                  ((syntax-descriptor? head)
  17.                   (tas-expand-special-form head exp syntax))
  18.                  (else
  19.                   (tas-expand-call exp syntax)))))))
  20.  
  21. (define (tas-expand-macros exp syntax) (tas-expand exp syntax))
  22.  
  23. (define *expander-table* (make-table '*expander-table*))
  24.  
  25. (define-local-syntax (define-expander pat vars . body)
  26.   (let ((exp-var (generate-symbol 'exp)))
  27.     `(set (table-entry *expander-table*
  28.                        (syntax-table-entry standard-syntax-table
  29.                                            ',(car pat)))
  30.           (lambda ,vars
  31.             (ignorable ,@vars)
  32.             (destructure ((,(cdr pat) (cdr ,(car vars))))
  33.               ,@body)))))
  34.  
  35. (define (tas-expand-special-form descr exp syntax)
  36.   (cond ((table-entry *expander-table* descr)
  37.          => (lambda (proc) (proc exp syntax)))
  38.         (else
  39.          (cond ((macro-expander? descr)
  40.                 (tas-expand (expand-macro-form descr exp syntax) syntax))
  41.                (else
  42.                 (error "unknown special form~%  ~S"
  43.                        `(tas-expand ,exp ,syntax)))))))
  44.  
  45. (define-expander (quote obj) (exp syntax)
  46.   (ignore obj)
  47.   exp)
  48.  
  49. (define-expander (variable-value name) (exp syntax)
  50.   `(,(car exp) ,name))
  51.  
  52. (define-expander (call . forms) (exp syntax)
  53.   (tas-expand-call forms syntax))
  54.  
  55. (define-expander (lambda vars . body) (exp syntax)
  56.   `(,(car exp) ,vars ,@(tas-expand-body body syntax)))
  57.  
  58. (define-expander (named-lambda name vars . body) (exp syntax)
  59.   `(,(car exp) ,name ,vars  ,@(tas-expand-body body syntax)))
  60.  
  61. (define-expander (if . rest) (exp syntax)
  62.   `(,(car exp) ,@(tas-expand-body rest syntax)))
  63.  
  64. (define-expander (labels specs . body) (exp syntax)
  65.   `(,(car exp) ,(map (lambda (spec)
  66.                        `(,(car spec) 
  67.                          ,@(tas-expand-body (cdr spec) syntax)))
  68.                      specs)
  69.                ,@(tas-expand-body body syntax)))
  70.  
  71. (define-expander (locale var . body) (exp syntax)
  72.   `(,(car exp) ,var ,@(tas-expand-body body syntax)))
  73.  
  74. (define-expander (block . body) (exp syntax)
  75.   `(,(car exp) ,@(tas-expand-body body syntax)))
  76.  
  77. (define-expander (define-variable-value var val) (exp syntax)
  78.   `(,(car exp) ,var ,(tas-expand val syntax)))
  79.  
  80. (define-expander (lset var val) (exp syntax)
  81.   `(,(car exp) ,var ,(tas-expand val syntax)))
  82.  
  83. (define-expander (set-variable-value var val) (exp syntax)
  84.   `(,(car exp) ,var ,(tas-expand val syntax)))
  85.  
  86. (define-expander (define-local-syntax . spec) (exp syntax)
  87.   (tas-set-local-syntax syntax spec)
  88.   `(define-local-syntax ,@spec))
  89.  
  90. (define-expander (let-syntax specs . body) (exp syntax)
  91.   (let ((syntax (make-syntax-table syntax nil)))
  92.     (walk (lambda (spec) (tas-set-local-syntax syntax spec))
  93.           specs)
  94.     `(let-syntax ,specs . ,(tas-expand-body body syntax))))
  95.  
  96. (define (tas-set-local-syntax syntax spec)
  97.   (let ((pat (car spec))
  98.         (body (cdr spec))
  99.         (foo (lambda (sym exp)
  100.                (set (syntax-table-entry syntax sym)
  101.                     (eval exp ((*value t-implementation-env
  102.                                        'env-for-syntax-definition)
  103.                                syntax)))
  104.                sym)))
  105.     (cond ((pair? pat)
  106.            (foo (car pat) `(macro-expander ,pat ,@body)))
  107.           (else
  108.            (foo pat (car body))))))
  109.  
  110. (define (tas-expand-call exp table)
  111.   (map (lambda (arg) (tas-expand arg table)) exp))
  112.  
  113. (define (tas-expand-body exp table)
  114.   (map (lambda (form) (tas-expand form table)) exp))
  115.